home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / compiler / emitcode.ml < prev    next >
Encoding:
Text File  |  1993-09-24  |  6.4 KB  |  207 lines  |  [TEXT/MPS ]
  1. (* Generation of bytecode for .zo files *)
  2.  
  3. #open "misc";;
  4. #open "const";;
  5. #open "instruct";;
  6. #open "prim";;
  7. #open "opcodes";;
  8. #open "prim_opc";;
  9. #open "buffcode";;
  10. #open "config";;
  11. #open "labels";;
  12.  
  13. let out_bool_test tst =
  14.   function PTeq -> out tst
  15.       |    PTnoteq -> out (tst + 1)
  16.       |    PTlt -> out (tst + 2)
  17.       |    PTgt -> out (tst + 3)
  18.       |    PTle -> out (tst + 4)
  19.       |    PTge -> out (tst + 5)
  20.       |    _ -> fatal_error "out_bool_test"
  21. ;;
  22.  
  23. let out_int_const i =
  24.   if i <= (maxint_byte-1)/2 & i >= (minint_byte-1)/2 then begin
  25.     out CONSTBYTE; out (i+i+1)
  26.   end else if i <= (maxint_short-1)/2 & i >= (minint_short-1)/2 then begin
  27.     out CONSTSHORT; out_short (i+i+1)
  28.   end else begin
  29.     out GETGLOBAL; reloc__slot_for_literal(SCatom(ACint i))
  30.   end
  31. ;;
  32.  
  33. let out_tag = function
  34.     ConstrRegular(t,_) ->
  35.       out t
  36.   | ConstrExtensible(name, stamp) ->
  37.       reloc__slot_for_tag name stamp
  38. ;;
  39.  
  40. let out_header (n, tag) =
  41.   out_tag tag;
  42.   out (lshift_left n 2);
  43.   out (lshift_right n 6);
  44.   out (lshift_right n 14)
  45. ;;
  46.  
  47. let rec emit = function
  48.       [] -> ()
  49.     | Kquote(SCatom(ACint i)) :: C ->
  50.         out_int_const i;
  51.         emit C
  52.     | Kquote(SCatom(ACchar c)) :: C ->
  53.         out_int_const (int_of_char c);
  54.         emit C
  55.     | Kquote(SCblock(tag,[])) :: C ->
  56.         begin match tag with
  57.           ConstrRegular(t, _) ->
  58.             if t < 10 then out (ATOM0 + t) else (out ATOM; out t)
  59.         | ConstrExtensible(name, stamp) ->
  60.             out ATOM; reloc__slot_for_tag name stamp
  61.         end;
  62.         emit C
  63.     | Kquote(sc) :: C ->
  64.         out GETGLOBAL;
  65.         reloc__slot_for_literal sc;
  66.         emit C
  67.     | Kget_global qualid :: C ->
  68.         out GETGLOBAL;
  69.         reloc__slot_for_get_global qualid;
  70.         emit C
  71.     | Kset_global qualid :: C ->
  72.         out SETGLOBAL;
  73.         reloc__slot_for_set_global qualid;
  74.         emit C
  75.     | Kaccess n :: C ->
  76.         if n < 6 then out(ACC0 + n) else (out ACCESS; out n);
  77.         emit C
  78.     | Kendlet n :: Kendlet p :: C ->
  79.         emit(Kendlet(n+p) :: C)
  80.     | Kendlet 1 :: C ->
  81.         out ENDLET1; emit C
  82.     | Kendlet n :: C ->
  83.         out ENDLET; out n; emit C
  84.     | Kletrec1 lbl :: C ->
  85.         out LETREC1; out_label lbl; emit C
  86.     | Kmakeblock(tag,n) :: C ->
  87.         if n <= 0 then
  88.           fatal_error "emit : Kmakeblock"
  89.         else if n < 5 then begin
  90.           out (MAKEBLOCK1 + n - 1);
  91.           out_tag tag
  92.         end else begin
  93.           out MAKEBLOCK;
  94.           out_header(n, tag)
  95.         end;
  96.         emit C
  97.     | Klabel lbl :: C ->
  98.         if lbl == Nolabel then fatal_error "emit: undefined label" else
  99.           (define_label lbl; emit C)
  100.     | Kclosure lbl :: C ->
  101.         out CUR; out_label lbl; emit C
  102.     | Kpushtrap lbl :: C ->
  103.         out PUSHTRAP; out_label lbl; emit C
  104.     | Kbranch lbl :: C ->
  105.         out BRANCH; out_label lbl; emit C
  106.     | Kbranchif lbl :: C ->
  107.         out BRANCHIF; out_label lbl; emit C
  108.     | Kbranchifnot lbl :: C ->
  109.         out BRANCHIFNOT; out_label lbl; emit C
  110.     | Kstrictbranchif lbl :: C ->
  111.         out BRANCHIF; out_label lbl; emit C
  112.     | Kstrictbranchifnot lbl :: C ->
  113.         out BRANCHIFNOT; out_label lbl; emit C
  114.     | Kswitch lblvect :: C ->
  115.         out SWITCH;
  116.         out (vect_length lblvect);
  117.         let orig = !out_position in
  118.         do_vect (out_label_with_orig orig) lblvect;
  119.         emit C
  120.     | Ktest(tst,lbl) :: C ->
  121.         begin match tst with
  122.             Peq_test ->
  123.               out BRANCHIFEQ; out_label lbl
  124.           | Pnoteq_test ->
  125.               out BRANCHIFNEQ; out_label lbl
  126.           | Pint_test(PTnoteqimm i) ->
  127.               out PUSH; out PUSH; out_int_const i;
  128.               out EQ; out POPBRANCHIFNOT; out_label lbl
  129.           | Pint_test x ->
  130.               out_bool_test BRANCHIFEQ x; out_label lbl
  131.           | Pfloat_test(PTnoteqimm f) ->
  132.               out PUSH; out PUSH; out GETGLOBAL;
  133.               reloc__slot_for_literal (SCatom(ACfloat f));
  134.               out EQFLOAT; out POPBRANCHIFNOT; out_label lbl
  135.           | Pfloat_test x ->
  136.               out_bool_test EQFLOAT x; out BRANCHIF; out_label lbl
  137.           | Pstring_test(PTnoteqimm s) ->
  138.               out PUSH; out PUSH; out GETGLOBAL;
  139.               reloc__slot_for_literal (SCatom(ACstring s));
  140.               out EQSTRING; out POPBRANCHIFNOT; out_label lbl
  141.           | Pstring_test x ->
  142.               out_bool_test EQSTRING x; out BRANCHIF; out_label lbl
  143.           | Pnoteqtag_test tag ->
  144.               out BRANCHIFNEQTAG; out_tag tag; out_label lbl
  145.         end;
  146.         emit C
  147.     | Kbranchinterval(low, high, lbl_low, lbl_high) :: C ->
  148.         out PUSH; out_int_const low; out PUSH;
  149.         if low != high then out_int_const high;
  150.         out BRANCHINTERVAL;
  151.         out_label lbl_low;
  152.         out_label lbl_high;
  153.         emit C
  154.     | Kprim Pidentity :: C ->
  155.         emit C
  156.     | Kprim p :: C ->
  157.         (match p with
  158.             Pdummy n ->
  159.               out DUMMY; out n
  160.           | Ptest tst ->
  161.               (match tst with
  162.                   Peq_test -> out EQ
  163.                 | Pnoteq_test -> out NEQ
  164.                 | Pint_test tst -> out_bool_test EQ tst
  165.                 | Pfloat_test tst -> out_bool_test EQFLOAT tst
  166.                 | Pstring_test tst -> out_bool_test EQSTRING tst
  167.                 | _ -> fatal_error "emit : Kprim, Ptest")
  168.           | Pfield n ->
  169.               if n < 4 then out (GETFIELD0 + n) else (out GETFIELD; out n)
  170.           | Psetfield n ->
  171.               if n < 4 then out (SETFIELD0 + n) else (out SETFIELD; out n)
  172.           | Pccall(name, arity) ->
  173.               if arity <= 5 then
  174.                 out (C_CALL1 + arity - 1)
  175.               else
  176.                 (out C_CALLN; out arity);
  177.               reloc__slot_for_c_prim name
  178.           | Pfloatprim p ->
  179.               out FLOATOP;
  180.               out(opcode_for_float_primitive p)
  181.           | p ->
  182.               out(opcode_for_primitive p));
  183.         emit C
  184.     | Kpush :: Kget_global qualid :: Kapply :: C ->
  185.         out PUSH_GETGLOBAL_APPLY;
  186.         reloc__slot_for_get_global qualid;
  187.         emit C
  188.     | Kpush :: Kget_global qualid :: Ktermapply :: C ->
  189.         out PUSH_GETGLOBAL_APPTERM;
  190.         reloc__slot_for_get_global qualid;
  191.         emit C
  192.     | instr :: C ->
  193.         out(match instr with
  194.            Kreturn -> RETURN
  195.         |  Kgrab -> GRAB
  196.         |  Kpush -> PUSH
  197.         |  Kpushmark -> PUSHMARK
  198.         |  Klet -> LET
  199.         |  Kapply -> APPLY
  200.         |  Ktermapply -> APPTERM
  201.         |  Kpoptrap -> POPTRAP
  202.         |  Kcheck_signals -> CHECK_SIGNALS
  203.         |  _  -> fatal_error "emit: should not happen");
  204.         emit C
  205. ;;
  206.  
  207.